home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 011 / autodesk.arc / PYRAMID.LSP < prev    next >
Encoding:
Text File  |  1987-04-21  |  6.6 KB  |  206 lines
  1. ;************************ PYRAMID.LSP **********************************
  2.  
  3. ;     By Simon Jones     Autodesk Ltd, London       March 1987
  4.  
  5. ; This macro constructs various tetrahedrons and pyramids with a flat base
  6. ; on the X-Y plane with either 3 or 4 corners using "3DFACES". A null
  7. ; response to the fourth base point will result in the construction of
  8. ; a three-point base.
  9.  
  10. ; Enter points in the same manner as "3DFACES".
  11.  
  12. ; The "TOP" option will construct pyramids with flat tops. This face may
  13. ; be closed or left open.
  14.  
  15. ; The "RIDGE" option will draw solids in the form of pitched roofs. To
  16. ; prevent the "bowtie" effect, enter the ridge points parallel to the side
  17. ; defined by the first and second base points. This option is only valid
  18. ; for four point base constructions.
  19.  
  20. ;**************************************************************************
  21.  
  22. (defun MODES (a)
  23.    (setq MLST '())
  24.    (repeat (length a)
  25.       (setq MLST (append MLST (list (list (car a) (getvar (car a))))))
  26.       (setq a (cdr a)))
  27. )
  28.  
  29. (defun MODER ()
  30.    (repeat (length MLST)
  31.       (setvar (caar MLST) (cadar MLST))
  32.       (setq MLST (cdr MLST))
  33.    )
  34. )
  35.  
  36. ;**************** CONSTRUCT 3D POINT **********************
  37.  
  38.  ; Construct point with elevation as Z coordinate
  39.  
  40. (defun CONPT (p prmpt el)
  41.   (initget 1)
  42.   (if p
  43.       (append (getpoint (xy p) prmpt) (list el))
  44.       (append (getpoint prmpt) (list el))
  45.   )
  46. )
  47.  
  48. (defun XY (pt)
  49.   (list (car pt) (cadr pt))
  50. )
  51.  
  52. ;*********************** MAIN PROGRAM *********************
  53.  
  54. (defun C:PYRAMID (/ prmpt b-el t-el bp1 bp2 bp3 bp4
  55.                     tp1 tp2 tp3 tp4 x col)
  56.  
  57.   ; Store system variable values
  58.   (modes '("elevation" "thickness" "cmdecho" "blipmode" "highlight"))
  59.   (setvar "cmdecho" 0)
  60.   (command "UNDO" "MARK")
  61.  
  62.   ; Constuction lines will only be drawn in "PLAN" view.
  63.   (if (and
  64.          (= (getvar "VPOINTX") 0.0)
  65.          (= (getvar "VPOINTY") 0.0)
  66.          (= (getvar "VPOINTZ") 1.0)
  67.       )
  68.       (setq col 2) ; Colour variable for construction lines
  69.       (setq col 0) ; 2=Yellow & 0=Blank
  70.   )
  71.  
  72.   ; Set base elevation
  73.   (setq prmpt (strcat "\nBase elevation <"
  74.                       (rtos (getvar "ELEVATION"))   ; Default "ELEVATION"
  75.                       ">: "                         ; variable
  76.               )
  77.   )
  78.   (setq b-el (getreal prmpt))
  79.   (if (null b-el) (setq b-el (getvar "ELEVATION")))
  80.  
  81.  
  82.   (if (equal (getvar "THICKNESS") 0.0)  ;Only prompt a default height
  83.       (progn                            ;if "THICKNESS" variable is non-zero
  84.         (initget (+ 1 2))
  85.         (setq t-el (getreal "\Height: "))
  86.       )
  87.       (progn
  88.        (setq prmpt (strcat "\nHeight <"
  89.                            (rtos (getvar "THICKNESS"))
  90.                            ">: "
  91.                    )
  92.        )
  93.        (initget 2)
  94.        (setq t-el (getreal prmpt))
  95.        (if (null t-el) (setq t-el (getvar "THICKNESS")))
  96.       )
  97.   )
  98.   (setq t-el (+ b-el t-el))
  99.  
  100.   (graphscr)
  101.   (setq bp1 (conpt nil "\nFirst base point: " b-el))
  102.   (setq bp2 (conpt bp1  "\nSecond base point: " b-el))
  103.   (grdraw (xy bp1) (xy bp2) col)
  104.   (setq bp3 (conpt bp2 "\nThird base point: " b-el))
  105.   (grdraw (xy bp2) (xy bp3) col)
  106.   (setq bp4 (getpoint (list (car bp3) (cadr bp3)) "\nFourth base point: "))
  107.  
  108.   (cond (bp4
  109.          (setq bp4 (append bp4 (list b-el)))
  110.          (grdraw (xy bp3) (xy bp4) col)
  111.          (grdraw (xy bp4) (xy bp1) col)
  112.          (initget 1 "Top Ridge")
  113.          (setq tp1 (getpoint "\nRidge/Top/<Apex point>: "))
  114.         )
  115.         (T
  116.          (grdraw (xy bp3) (xy bp1) col)
  117.          (initget 1 "Top")
  118.          (setq tp1 (getpoint "\nTop/<Apex point>: "))
  119.         )
  120.   )
  121.  
  122.   (cond
  123.         ((= tp1 "Top")   ; Truncated pyramid option.
  124.          (setq tp1 (conpt nil " \nFirst top point: " t-el))
  125.          (setq tp2 (conpt tp1 "\nSecond top point: " t-el))
  126.          (grdraw (xy tp1) (xy tp2) col)
  127.          (setq tp3 (conpt tp2 "\nThird top point: " t-el))
  128.          (grdraw (xy tp2) (xy tp3) col)
  129.          (if bp4
  130.                 (progn
  131.                  (setq tp4 (conpt tp3 "\nFourth top point: " t-el))
  132.                  (grdraw (xy tp3) (xy tp4) col)
  133.                  (grdraw (xy tp4) (xy tp1) col)
  134.                 )
  135.                 (grdraw (xy tp3) (xy tp1) col)
  136.          )
  137.          (setvar "BLIPMODE" 0)
  138.          (initget "Yes No")
  139.          (setq x (getkword "\nClose top face (Yes or No) <Y>: "))
  140.          (if (null x) (setq x "Yes"))
  141.          (if bp4
  142.                (progn
  143.                 (if (equal x "Yes")
  144.                     (command "3DFACE" tp1 tp2 tp3 tp4 "")
  145.                 )
  146.                 (command "3DFACE" bp1 tp1 tp2 bp2 bp3
  147.                                   tp3 tp4 bp4 bp1 tp1 ""
  148.                 )
  149.                )
  150.                (progn
  151.                 (if (equal x "Yes")
  152.                     (command "3DFACE" tp1 tp2 tp3 "" "")
  153.                 )
  154.                 (command "3DFACE" bp1 tp1 tp2 bp2 bp3 tp3 tp1 bp1 "")
  155.                )
  156.          )
  157.         )
  158.         ((= tp1 "Ridge")   ; Ridged "roof" option
  159.          (setq tp1 (conpt nil "\nFirst ridge point: " t-el))
  160.          (setq tp2 (conpt tp1 "\nSecond ridge point: " t-el))
  161.          (grdraw (xy tp1) (xy tp2) col)
  162.          (setq xx "Yes")
  163.          (setvar "BLIPMODE" 0)
  164.          (if (/= (angle bp1 bp2) (angle tp1 tp2))
  165.              (progn
  166.                (initget "Yes No")
  167.                (prompt "\nRidge is not parallel to first edge. ")
  168.                (prompt "\nProceed (Yes or No) <N>: ")
  169.                (setq xx (getkword))
  170.               )
  171.          )
  172.          (cond ((= xx "Yes")
  173.                 (command "3DFACE" bp1 tp1 tp2 bp2 ""
  174.                          "3DFACE" bp2 bp3 tp2 "" ""
  175.                          "3DFACE" bp3 tp2 tp1 bp4 ""
  176.                          "3DFACE" bp4 tp1 bp1 "" ""
  177.                 )
  178.                )
  179.                (T
  180.                 (grdraw (xy bp1) (xy bp2) 0)
  181.                 (grdraw (xy bp2) (xy bp3) 0)
  182.                 (grdraw (xy bp3) (xy bp4) 0)
  183.                 (grdraw (xy bp4) (xy bp1) 0)
  184.                 (grdraw (xy tp1) (xy tp2) 0)
  185.                )
  186.          )
  187.         )
  188.         (T     ; Default option "Apex point"
  189.          (setq tp1 (append tp1 (list t-el)))
  190.          (if bp4
  191.              (command "3DFACE" bp1 bp2 tp1 "" ""
  192.                       "3DFACE" bp2 bp3 tp1 "" ""
  193.                       "3DFACE" bp3 bp4 tp1 "" ""
  194.                       "3DFACE" bp4 bp1 tp1 "" ""
  195.  
  196.              )
  197.              (command "3DFACE" bp1 bp2 tp1 "" ""
  198.                       "3DFACE" bp2 bp3 tp1 "" ""
  199.                       "3DFACE" bp3 bp1 tp1 "" ""
  200.              )
  201.          )
  202.         )
  203.   )
  204.   (moder) ; Reset system variables
  205.   (princ)
  206. )